Case 1 Learning Objective 4

1 Analyzing medical students scores

Background given in the case desciprtion: “The course lasts twelve weeks. Throughout the course, students are assessed in multiple ways, including weekly quizzes, slide exams, and essays. They also take an end of course exam that includes essay, short answer, and multiple-choice components. The final data has the average scores for those assessments. Students are required to take laboratory practical (gross anatomy, histology, pathology and neuroanatomy) exams which are averaged into the final grade. Students also take a National Board of Medical Examiners (NBME) standardized exam in each course. Theoretically, if they do well on these exams, they should do well in the course overall. All of the assessments have been calculated on a 100- point scale.”

1.1 Questions from Learning Objective 4

• How should we define not pass/ marginal pass/ pass thresholds and criteria?
• How do these thresholds compare to final exam scores

1.2 Data

There are 92 students.

Code

label(dt$quiz)      <- "Quiz score (mean weekly performance)"
label(dt$nbme)      <- "National Board of Medical Examiners score"
label(dt$ga)        <- "GA"
label(dt$slide)      <- "Slide exams score (mean)"
label(dt$part.c)      <- "Part C score"
label(dt$essay)      <- "Essay score (mean)"
label(dt$eob.exam)      <- "EOB exam"
label(dt$final)      <- "Final score"

table1(~quiz + nbme + ga + slide + part.c + essay+ eob.exam + final , data=dt, topclass="Rtable1-zebra",)

	Overall (N=92)
Quiz score (mean weekly performance)
Mean (SD)	0.821 (0.0685)
Median [Min, Max]	0.820 [0.660, 1.00]
National Board of Medical Examiners score
Mean (SD)	89.9 (5.45)
Median [Min, Max]	91.0 [74.0, 100]
GA
Mean (SD)	83.0 (9.89)
Median [Min, Max]	83.9 [49.5, 100]
Slide exams score (mean)
Mean (SD)	82.3 (10.0)
Median [Min, Max]	83.9 [53.1, 100]
Part C score
Mean (SD)	81.1 (8.70)
Median [Min, Max]	81.6 [59.6, 100]
Essay score (mean)
Mean (SD)	86.8 (5.42)
Median [Min, Max]	87.3 [71.3, 95.8]
EOB exam
Mean (SD)	84.9 (6.83)
Median [Min, Max]	85.0 [65.0, 99.0]
Final score
Mean (SD)	88.5 (5.63)
Median [Min, Max]	88.5 [68.0, 100]

Code

length(unique(dt$id))

[1] 92

Questions for Mario:

• What does GA stand for in the data? What does part.c stand for in the data? What does eob refer to on the exam? Where is the score for the laboratory practical?

• Can we assume the slide exam score is a mean?

Code

dt = dt %>% 
  mutate(quiz = 100*quiz)

tableby(pass~.,dt %>% 
          select(-id) %>% 
          mutate(pass = final>70),
        control = 
          tableby.control(
            numeric.stats = c("meansd","median","range"),
          )) %>% 
  summary() %>% 
  knitr::kable()

	FALSE (N=2)	TRUE (N=90)	Total (N=92)	p value
Quiz score (mean weekly performance)				0.011
Mean (SD)	70.000 (1.881)	82.377 (6.679)	82.108 (6.853)
Median	70.000	82.335	82.000
Range	68.670 - 71.330	66.000 - 100.000	66.000 - 100.000
National Board of Medical Examiners score				< 0.001
Mean (SD)	76.000 (2.828)	90.178 (5.087)	89.870 (5.452)
Median	76.000	91.000	91.000
Range	74.000 - 78.000	78.000 - 100.000	74.000 - 100.000
GA				0.002
Mean (SD)	61.735 (17.317)	83.446 (9.285)	82.974 (9.887)
Median	61.735	84.439	83.929
Range	49.490 - 73.980	51.531 - 100.000	49.490 - 100.000
Slide exams score (mean)				0.001
Mean (SD)	60.455 (2.524)	82.736 (9.558)	82.252 (10.005)
Median	60.455	84.180	83.925
Range	58.670 - 62.240	53.060 - 100.000	53.060 - 100.000
Part C score				< 0.001
Mean (SD)	61.410 (2.517)	81.549 (8.271)	81.112 (8.700)
Median	61.410	81.980	81.590
Range	59.630 - 63.190	64.230 - 100.000	59.630 - 100.000
Essay score (mean)				< 0.001
Mean (SD)	73.625 (3.359)	87.059 (5.091)	86.767 (5.418)
Median	73.625	87.250	87.250
Range	71.250 - 76.000	71.250 - 95.750	71.250 - 95.750
EOB exam				< 0.001
Mean (SD)	66.500 (2.121)	85.322 (6.317)	84.913 (6.833)
Median	66.500	85.000	85.000
Range	65.000 - 68.000	69.000 - 99.000	65.000 - 99.000
Final score				< 0.001
Mean (SD)	68.000 (0.000)	88.911 (4.773)	88.457 (5.628)
Median	68.000	89.000	88.500
Range	68.000 - 68.000	78.000 - 100.000	68.000 - 100.000

Code

set.seed(123123)
pc = prcomp(dt %>% select(-id,-final) %>% mutate_all(scale))

Code

ggpairs(dt %>% select(-id),
        aes(color=ifelse(final>80,"pass","(almost)fail")),
        progress = F)

Code

cl = kmeans(dt %>% select(-id) %>% mutate_all(scale),
            centers = 4)$cluster
dt %>% left_join(tibble(id = dt$id,cluster = as.factor(cl))) %>% 
  cbind(pc$x) %>% 
  ggplot(aes(x=PC1,y=final,color=cluster)) +
  scale_color_calc()+
  geom_jitter()

Joining with `by = join_by(id)`

Code

autoplot(pc,color = as.factor(cl))

Warning in !(is.vector(value) && length(value) > 1L) && value %in% columns:
'length(x) = 92 > 1' in coercion to 'logical(1)'

1.3 Can I create a better metric?

Code

overall = 
  0.6*rowMeans(dt %>% select(-id,-final,-nbme)) +
  0.4*dt$nbme
dt %>% select(-id) %>% 
  mutate(overall = overall) %>% 
  ggpairs(.,
          aes(color = ifelse(
            overall> quantile(overall,0.05),
            "pass","fail")),
          progress = F)

Code

dt  %>% 
  mutate(overall = overall,
         pass = overall>quantile(overall,0.05)) %>% 
  cbind(pc$x) %>% 
ggplot(aes(y=PC2,x=PC1,color=pass))+
  geom_jitter()

Code

overall = scale(pc$x)[,1:2] %*% c(-0.8,0.2) 

dt %>% select(-id) %>% 
  mutate(overall = as.numeric(overall)) %>% 
  ggpairs(.,
          aes(color = ifelse(
            overall> quantile(overall,0.05),
            "pass","fail")),
          progress = F)

Code

dt  %>% 
  mutate(overall = overall,
         pass = overall>quantile(overall,0.05)) %>% 
  cbind(pc$x) %>% 
ggplot(aes(x=PC1,y=PC2,color=pass))+
  geom_jitter()